home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_013 / fractalrep.bas < prev    next >
BASIC Source File  |  1992-05-06  |  6KB  |  133 lines
  1. 10    screen 1,4,0: randomize -1: pena 7
  2. 11    rgb 1,15,15,15:rgb 8,10,8,6
  3. 12    rgb 11,0,10,15
  4. 20    dim d(64,32)
  5. 30    input "Number of levels <1-6> ";le: if le < 1 or le > 6 then 30
  6. 40    ds=2: for n=1 to le:ds=ds+2^(n-1):next n
  7. 50    mx=ds-1:my=mx/2:rh=pi*30/180:vt=rh*1.2
  8. 60    for n=1 to le:L=10000/1.8^n
  9. 70    ?: ? "Working on level ";n
  10. 80    ib=mx/2^n:sk=ib*2
  11. 90    gosub 150: ' *** Assign heights along X in array ***
  12. 100   gosub 220: ' *** Assign heights along Y in array ***
  13. 110   gosub 290: ' *** Assign heights along diag. in array ***
  14. 120   next n
  15. 130   goto 640:  ' *** Draw ***
  16. 140   ' *** Heights along x ***
  17. 150   for ye = 0 to mx - 1 step sk
  18. 160   for xe = ib+ye to mx step sk
  19. 170   ax = xe-ib: ay = ye: gosub 370: d1=d: ax = xe+ib: gosub 370:                 d2 = d
  20. 180   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  21. 190   next xe
  22. 200   next ye: return
  23. 210   ' *** Heights along Y ***
  24. 220   for xe = mx to 1 step -sk
  25. 230   for ye = ib to xe step sk
  26. 240   ax = xe: ay = ye + ib: gosub 370: d1 = d: ay = ye - ib: gosub 370:           d2 = d
  27. 250   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  28. 260   next ye
  29. 270   next xe: return
  30. 280   ' *** Heights along diag. ***
  31. 290   for xe = 0 to mx - 1 step sk
  32. 300   for ye = ib to mx - xe step sk
  33. 310   ax = xe + ye - ib: ay = ye - ib: gosub 370: d1 = d
  34. 320   ax = xe + ye + ib: ay = ye + ib: gosub 370: d2 = d
  35. 330   ax = xe + ye: ay = ye: d = (d1+d2)/2 + rnd(1) * L/2 - L/4:                  gosub 420
  36. 340   next ye
  37. 350   next xe: return
  38. 360   ' *** Return data from array ***
  39. 370   if ay > my then 390
  40. 380   by = ay: bx = ax: goto 400
  41. 390   by = mx+1-ay: bx = mx-ax
  42. 400   d = d(bx,by): return
  43. 410   ' *** Put data into array ***
  44. 420   if ay > my then 440
  45. 430   by = ay: bx = ax: goto 450
  46. 440   by = mx+1-ay: bx = mx-ax
  47. 450   d(bx,by) = d: return
  48. 460   ' *** Put in sea level here ***
  49. 470   if xo <> -999 then 500
  50. 480   if zz < 0 then gosub 1070: z2 = zz: zz = 0: goto 620
  51. 490   gosub 1090: goto 610
  52. 500   if z2 > 0 and zz > 0 then 610
  53. 510   if z2 < 0 and zz < 0 then z2 = zz: zz = 0: goto 620
  54. 520   w3 = zz/(zz-z2): x3 = (x2-xx) * w3 + xx: y3 = (y2-yy) * w3 + yy:             z3 = 0
  55. 530   zt = zz: yt = yy: xt = xx
  56. 540   if zz > 0 then 590
  57. 550   ' *** Going into water ***
  58. 560   zz = z3: yy = y3: xx = x3: gosub 950
  59. 570   gosub 1070: zz = 0: yy = yt: xx = xt: z2 = zt: goto 620
  60. 580   ' *** Coming up out of water ***
  61. 590   zz = z3: yy= y3: xx= x3: gosub 950
  62. 600   gosub 1090: zz = zt: yy = yt: xx = xt
  63. 610   z2 = zz
  64. 620   x2 = xx: y2 = yy: return
  65. 630   ' **** Display here ****
  66. 640   gosub 1100: ' *** Set up plotting device or screen ***
  67. 650   xs = .04: ys = .04: zs = .04: ' *** scaling factors ***
  68. 660   for ax = 0 to mx: xo = -999: for ay = 0 to ax
  69. 670   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  70. 680   gosub 940: next ay: next ax
  71. 690   for ay = 0 to mx: xo = -999: for ax = ay to mx
  72. 700   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  73. 710   gosub 940: next ax: next ay
  74. 720   for ex = 0 to mx: xo = -999: for ey = 0 to mx-ex
  75. 730   ax = ex + ey: ay = ey: gosub 370: zz = d: yy = ay/mx *10000
  76. 740   xx = ax/mx * 10000 - yy/2: gosub 940: next ey: next ex
  77. 750   goto 1130: ' *** done plotting, goto end loop ***
  78. 760   ' *** Rotate ***
  79. 770   if xx <> 0 then 800
  80. 780   if yy <= 0 then ra = -pi/2: goto 820
  81. 790   ra = pi/2: goto 820
  82. 800   ra = atn(yy/xx)
  83. 810   if xx < 0 then ra = ra + pi
  84. 820   r1 = ra + rh: rd = sqr (xx*xx + yy*yy)
  85. 830   xx = rd * cos(r1): yy = rd * sin(r1)
  86. 840   return
  87. 850   ' *** Tilt down ***
  88. 860   rd = sqr(zz*zz + xx*xx)
  89. 870   if xx = 0 then ra = pi/2: goto 900
  90. 880   ra = atn (zz/xx)
  91. 890   if xx < 0 then ra = ra + pi
  92. 900   r1 = ra - vt
  93. 910   xx = rd * cos(r1) + xx: zz = rd * sin(r1)
  94. 920   return
  95. 930   ' *** Move or plot to (xp,yp)
  96. 940   gosub 470
  97. 950   xx = xx * xs: yy = yy * ys: zz = zz * zs
  98. 960   gosub 770: ' *** Rotate ***
  99. 970   gosub 860: ' *** Tilt up ***
  100. 980   if xo = -999 then pr$ = "M"
  101. 985   if xo <> -999 then pr$ = "D"
  102. 990   xp = int(yy) + cx: yp = int(zz)
  103. 1000  gosub 1030
  104. 1010  return
  105. 1020  ' *** plot line here ***
  106. 1030  xp = xp * 1.3: yp = 33.14 - .623 * yp
  107. 1040  if pr$ = "M" then x8 = xp: y8 = yp: xo = x
  108. 1045  if y8 > 199 or y8 < 0 or yp > 199 or yp < 0 then return
  109. 1050  draw (x8,y8 to xp,yp): x8 = xp: y8 = yp: return
  110. 1060  ' *** switch to sea color ***
  111. 1070  pena 11: return
  112. 1080  ' *** switch to land color ***
  113. 1090  pena 8: return
  114. 1100  ' * * * setup plotting device or screen * * *
  115. 1110  scnclr: pena 1: area (0,0 to 0,200 to 620,200 to 620,0 to 0,0):              return
  116. 1120  ' *** End loop ***
  117. 1130  getkey a$
  118. 1140  end
  119. 60000 '   This program come from "Creative Computing" July 1985 pp 78-82
  120. 60010 ' by Michiel van de Panne.  He used the method of generating
  121. 60020 ' fractal landscapes from the September 1984 issue of "Scientific
  122. 60030 ' American".  To modify the program you can change the color of
  123. 60040 ' pena in line 1070 and in line 1090.  You can change the
  124. 60050 ' background color by changing pena to a different color in line
  125. 60060 ' 1110.  The program can only handle 6 levels with a dimension of
  126. 60070 ' d(64,32) in line 20 -- if you want to wait for level 7 to be
  127. 60080 ' plotted, change line 20 to dimension d as dim d(128,64) for 
  128. 60090 ' 16384 triangles to generated.
  129. 60100 '   The size of the landscape can be scaled in line 1030.
  130. 60110 ' Line 10 and lines 1030-1040 have the computer dependent code.
  131. 60120 ' To remove the seas from the landscape change line 470 to read
  132. 60130 ' 470 return
  133.